home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / The World of Computer Software.iso / srcuc.zip / INTERP.H < prev    next >
C/C++ Source or Header  |  1991-07-18  |  9KB  |  292 lines
  1. /* -*-C-*-
  2.  
  3. $Header: /scheme/microcode/RCS/interp.h,v 9.34 1991/07/18 15:59:41 markf Exp $
  4.  
  5. Copyright (c) 1987, 1988, 1989, 1990 Massachusetts Institute of Technology
  6.  
  7. This material was developed by the Scheme project at the Massachusetts
  8. Institute of Technology, Department of Electrical Engineering and
  9. Computer Science.  Permission to copy this software, to redistribute
  10. it, and to use it for any purpose is granted, subject to the following
  11. restrictions and understandings.
  12.  
  13. 1. Any copy made of this software must include this copyright notice
  14. in full.
  15.  
  16. 2. Users of this software agree to make their best efforts (a) to
  17. return to the MIT Scheme project any improvements or extensions that
  18. they make, so that these may be included in future releases; and (b)
  19. to inform MIT of noteworthy uses of this software.
  20.  
  21. 3. All materials developed as a consequence of the use of this
  22. software shall duly acknowledge such use, in accordance with the usual
  23. standards of acknowledging credit in academic research.
  24.  
  25. 4. MIT has made no warrantee or representation that the operation of
  26. this software will be error-free, and MIT is under no obligation to
  27. provide any services, by way of maintenance, update, or otherwise.
  28.  
  29. 5. In conjunction with products arising from the use of this material,
  30. there shall be no use of the name of the Massachusetts Institute of
  31. Technology nor of any adaptation thereof in any advertising,
  32. promotional, or sales literature without prior written consent from
  33. MIT in each case. */
  34.  
  35. /* Macros used by the interpreter and some utilities. */
  36.  
  37. extern void EXFUN (abort_to_interpreter, (int argument));
  38. extern int EXFUN (abort_to_interpreter_argument, (void));
  39.  
  40.                      /********************/
  41.                      /* OPEN CODED RACKS */
  42.                      /********************/
  43.  
  44. /* Move from register to static storage and back */
  45.  
  46. /* Note defined() cannot be used because VMS does not understand it. */
  47.  
  48. #ifdef In_Main_Interpreter
  49. #ifndef ENABLE_DEBUGGING_TOOLS
  50. #define Cache_Registers
  51. #endif
  52. #endif
  53.  
  54. #ifdef Cache_Registers
  55.  
  56. #define Regs        Reg_Block
  57. #define Stack_Pointer    Reg_Stack_Pointer
  58. #define History        Reg_History
  59.  
  60. #define Import_Registers()                        \
  61. {                                    \
  62.   Reg_Stack_Pointer = Ext_Stack_Pointer;                \
  63.   Reg_History = Ext_History;                        \
  64. }
  65.  
  66. #define Export_Registers()                        \
  67. {                                    \
  68.   Ext_History = Reg_History;                        \
  69.   Ext_Stack_Pointer = Reg_Stack_Pointer;                \
  70. }
  71.  
  72. #else
  73.  
  74. #define Regs        Registers
  75. #define Stack_Pointer    Ext_Stack_Pointer
  76. #define History        Ext_History
  77.  
  78. #define Import_Registers()
  79. #define Export_Registers()
  80.  
  81. #endif
  82.  
  83. #define Import_Val()
  84. #define Import_Registers_Except_Val()        Import_Registers()
  85.  
  86. #define IMPORT_REGS_AFTER_PRIMITIVE()
  87. #define EXPORT_REGS_BEFORE_PRIMITIVE Export_Registers
  88.  
  89. #define Env        Regs[REGBLOCK_ENV]
  90. #define Val        Regs[REGBLOCK_VAL]
  91. #define Expression    Regs[REGBLOCK_EXPR]
  92. #define Return        Regs[REGBLOCK_RETURN]
  93.  
  94. /* Internal_Will_Push is in stack.h. */
  95.  
  96. #ifdef ENABLE_DEBUGGING_TOOLS
  97.  
  98. #define Will_Push(N)                            \
  99. {                                    \
  100.   SCHEME_OBJECT *Will_Push_Limit;                    \
  101.                                     \
  102.   Internal_Will_Push((N));                        \
  103.   Will_Push_Limit = (STACK_LOC (- (N)))
  104.  
  105. #define Pushed()                            \
  106.   if (Stack_Pointer < Will_Push_Limit)                    \
  107.   {                                    \
  108.     Stack_Death();                            \
  109.   }                                    \
  110. }
  111.  
  112. #else
  113.  
  114. #define Will_Push(N)            Internal_Will_Push(N)
  115. #define Pushed()            /* No op */
  116.  
  117. #endif
  118.  
  119. /*
  120.   N in Will_Eventually_Push is the maximum contiguous (single return code)
  121.   amount that this operation may take.  On the average case it may use less.
  122.   M in Finished_Eventual_Pushing is the amount not yet pushed.
  123.  */
  124.  
  125. #define Will_Eventually_Push(N)        Internal_Will_Push(N)
  126. #define Finished_Eventual_Pushing(M)    /* No op */
  127.  
  128. /* Primitive stack operations:
  129.    These operations hide the direction of stack growth.
  130.    `Throw' in "stack.h", `Allocate_New_Stacklet' in "utils.c",
  131.    `apply', `cwcc' and friends in "hooks.c", and possibly other stuff,
  132.    depend on the direction in which the stack grows. */
  133.  
  134. #define STACK_LOCATIVE_DECREMENT(locative) (-- (locative))
  135. #define STACK_LOCATIVE_INCREMENT(locative) ((locative) ++)
  136. #define STACK_LOCATIVE_OFFSET(locative, offset) ((locative) + (offset))
  137. #define STACK_LOCATIVE_REFERENCE(locative, offset) ((locative) [(offset)])
  138. #define STACK_LOCATIVE_DIFFERENCE(x, y) ((x) - (y))
  139.  
  140. #define STACK_LOCATIVE_PUSH(locative)                    \
  141.   (* (STACK_LOCATIVE_DECREMENT (locative)))
  142.  
  143. #define STACK_LOCATIVE_POP(locative)                    \
  144.   (* (STACK_LOCATIVE_INCREMENT (locative)))
  145.  
  146. #define STACK_PUSH(object) (STACK_LOCATIVE_PUSH (Stack_Pointer)) = (object)
  147. #define STACK_POP() (STACK_LOCATIVE_POP (Stack_Pointer))
  148. #define STACK_LOC(offset) (STACK_LOCATIVE_OFFSET (Stack_Pointer, (offset)))
  149. #define STACK_REF(offset) (STACK_LOCATIVE_REFERENCE (Stack_Pointer, (offset)))
  150.  
  151. /* Fetch from register */
  152.  
  153. #define Fetch_Expression()    Expression
  154. #define Fetch_Env()        Env
  155. #define Fetch_Return()        Return
  156.  
  157. /* Store into register */
  158.  
  159. #define Store_Expression(P)    Expression = (P)
  160. #define Store_Env(P)        Env = (P)
  161. #define Store_Return(P)                            \
  162.   Return = MAKE_OBJECT (TC_RETURN_CODE, (P))
  163.  
  164. #define Save_Env()        STACK_PUSH (Env)
  165. #define Restore_Env()        Env = (STACK_POP ())
  166. #define Restore_Then_Save_Env()    Env = (STACK_REF (0))
  167.  
  168. /* Note: Save_Cont must match the definitions in sdata.h */
  169.  
  170. #define Save_Cont()                            \
  171. {                                    \
  172.   STACK_PUSH (Expression);                        \
  173.   STACK_PUSH (Return);                            \
  174.   Cont_Print ();                            \
  175. }
  176.  
  177. #define Restore_Cont()                            \
  178. {                                    \
  179.   Return = (STACK_POP ());                        \
  180.   Expression = (STACK_POP ());                        \
  181.   if (Cont_Debug)                            \
  182.   {                                    \
  183.     Print_Return(RESTORE_CONT_RETURN_MESSAGE);                \
  184.     Print_Expression(Fetch_Expression(),                \
  185.              RESTORE_CONT_EXPR_MESSAGE);            \
  186.     printf ("\n");                            \
  187.   }                                    \
  188. }
  189.  
  190. #define Cont_Print()                            \
  191. {                                    \
  192.   if (Cont_Debug)                            \
  193.   {                                    \
  194.     Print_Return(CONT_PRINT_RETURN_MESSAGE);                \
  195.     Print_Expression(Fetch_Expression(),                \
  196.              CONT_PRINT_EXPR_MESSAGE);                \
  197.     printf ("\n");                            \
  198.   }                                    \
  199. }
  200.  
  201. #define Stop_Trapping()                            \
  202. {                                    \
  203.   Trapping = false;                            \
  204. }
  205.  
  206. /* Primitive utility macros */
  207.  
  208. /* A primitive object has two components (besides the type code), a
  209.    table index in the low 12 bits (assuming datum fields are 24 bits
  210.    wide), and a virtual index in the upper 12 bits.  The table index
  211.    is always guaranteed to be a valid entry into
  212.    Primitive_Procedure_Table.  For unimplemented primitives it is the
  213.    index of the last entry in the table, which causes an error when
  214.    invoked.  For implemented primitives it is the real index.  The
  215.    virtual index is 0 for implemented primitives (for histerical
  216.    reasons), and the actual virtual index (higher than any real table
  217.    index) for unimplemented primitives.
  218.  */
  219.  
  220. #define PRIMITIVE_TABLE_INDEX(primitive)                \
  221. ((primitive) & HALF_DATUM_MASK)
  222.  
  223. #define PRIMITIVE_VIRTUAL_INDEX(primitive)                \
  224. (((primitive) >> HALF_DATUM_LENGTH) & HALF_DATUM_MASK)
  225.  
  226. #define MAKE_PRIMITIVE_OBJECT(virtual, real)                \
  227. (MAKE_OBJECT (TC_PRIMITIVE, (((virtual) << HALF_DATUM_LENGTH) | (real))))
  228.  
  229. /* Does this fail for the first unimplemented primitive if there are no
  230.    implemented primitives?
  231.  */
  232.  
  233. #define IMPLEMENTED_PRIMITIVE_P(primitive)                \
  234. (PRIMITIVE_VIRTUAL_INDEX(primitive) == 0)
  235.  
  236. #define PRIMITIVE_NUMBER(primitive)                    \
  237. ((IMPLEMENTED_PRIMITIVE_P(primitive))    ?                \
  238.  (PRIMITIVE_TABLE_INDEX(primitive))    :                \
  239.  (PRIMITIVE_VIRTUAL_INDEX(primitive)))
  240.  
  241. /* This will automagically cause an error if the primitive is
  242.    not implemented. */
  243.  
  244. #ifndef ENABLE_DEBUGGING_TOOLS
  245.  
  246. #define PRIMITIVE_APPLY PRIMITIVE_APPLY_INTERNAL
  247.  
  248. #else
  249.  
  250. extern SCHEME_OBJECT EXFUN
  251.   (primitive_apply_internal, (SCHEME_OBJECT primitive));
  252. #define PRIMITIVE_APPLY(loc, primitive)                    \
  253.   (loc) = (primitive_apply_internal (primitive))
  254.  
  255. #endif
  256.  
  257. extern char * EXFUN (primitive_to_name, (SCHEME_OBJECT primitive));
  258. extern long EXFUN (primitive_to_arity, (SCHEME_OBJECT primitive));
  259. extern long EXFUN (primitive_to_arguments, (SCHEME_OBJECT primitive));
  260.  
  261. #define PRIMITIVE_APPLY_INTERNAL(loc, primitive)            \
  262. {                                    \
  263.   (Regs[REGBLOCK_PRIMITIVE]) = (primitive);                \
  264.   {                                    \
  265.     /* Save the dynamic-stack position. */                \
  266.     PTR PRIMITIVE_APPLY_INTERNAL_position = dstack_position;        \
  267.     (loc) =                                \
  268.       ((*                                \
  269.     (Primitive_Procedure_Table                    \
  270.      [PRIMITIVE_TABLE_INDEX (primitive)]))                \
  271.        ());                                \
  272.     /* If the primitive failed to unwind the dynamic stack, lose. */    \
  273.     if (PRIMITIVE_APPLY_INTERNAL_position != dstack_position)        \
  274.       {                                    \
  275.     fprintf (stderr, "\nPrimitive slipped the dynamic stack: %s\n",    \
  276.          (primitive_to_name (primitive)));            \
  277.     fflush (stderr);                        \
  278.     Microcode_Termination (TERM_EXIT);                \
  279.       }                                    \
  280.   }                                    \
  281.   (Regs[REGBLOCK_PRIMITIVE]) = SHARP_F;                    \
  282. }
  283.  
  284. /* This is only valid for implemented primitives. */
  285.  
  286. #define PRIMITIVE_ARITY(primitive)                    \
  287.   (Primitive_Arity_Table [PRIMITIVE_TABLE_INDEX (primitive)])
  288.  
  289. #define PRIMITIVE_N_PARAMETERS primitive_to_arity
  290. #define PRIMITIVE_N_ARGUMENTS primitive_to_arguments
  291. #define POP_PRIMITIVE_FRAME(arity) Stack_Pointer = (STACK_LOC (arity))
  292.